home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / IFF / iff_support < prev    next >
Encoding:
Text File  |  1992-03-20  |  5.8 KB  |  298 lines
  1. \ Parse IFF graphics files.
  2. \
  3. \ IFF = Interchange File Format
  4. \ This is the format for Paint Pictures, etc.
  5. \
  6. \ Author: Phil Burk
  7. \ Copyright 1988 Phil Burk
  8. \
  9. \ MOD: PLB, S. Harmon, 1/19/90 INCLUDE? 'ILBM' instead of 'FORM'
  10. \ MOD: PLB 12/16/90 Add IFF-WARNINGS variable.
  11. \ 00001 PLB/ND 10/25/91 Allow non aborting IFF.ERROR in $IFF.OPEN
  12. \ 00002 PLB 10/29/91 Add IFF-STOP
  13. \ 00003 PLB 11/14/91 Add proper error handling capability.
  14. \ 00004 PLB 3/20/91 Fixed error handling in IFF.READ.CHKID
  15.  
  16. include? 'ILBM' jiff:iff.j  ( 1/19/90 )
  17. include? { ju:locals
  18. include? goto.error ju:goto_error
  19. decimal
  20.  
  21. ANEW TASK-IFF_SUPPORT
  22.  
  23. variable IFF-FILEID
  24. variable IFF-PAD 16 allot
  25. variable IFF-NESTED
  26. variable IFF-WARNINGS
  27. variable IFF-STOP \ variable to tell parser/scanners to stop 00002
  28. variable IFF-ERROR \ set by parsers if an error is encountered 00003
  29.  
  30. DEFER IFF.PROCESS.CHUNK
  31. DEFER IFF.PROCESS.FORM
  32. DEFER IFF.PROCESS.CAT
  33. DEFER IFF.PROCESS.LIST
  34.  
  35. : .CHKID ( 'chkid' -- , print chunk id )
  36.     pad ! pad 4 type
  37. ;
  38.  
  39. : IFF.CLOSE ( -- , close any currently open file )
  40.     iff-fileid @ ?dup
  41.     IF  fclose
  42.         0 iff-fileid !
  43.     THEN
  44. ;
  45.  
  46. : $IFF.OPEN?  { $filename -- fileid | 0 }
  47.     iff.close
  48.     $filename c@ 0=
  49.     IF ." $IFF.OPEN - No filename given!" cr 0
  50.     ELSE \ 00001
  51.         $filename $fopen dup 0=
  52.         IF
  53.             ." Couldn't open file: " $filename $type cr
  54.         ELSE \ 00001
  55.             dup iff-fileid !
  56.         THEN
  57.     THEN
  58. ;
  59.  
  60. : IFF.READ ( addr #bytes -- #bytes , read from open IFF file)
  61.     iff-fileid @ -rot    fread
  62. ;
  63.  
  64. : IFF.READ? ( addr #bytes -- error? , read from open IFF file)
  65.     tuck 
  66.     iff.read
  67.     = not
  68. ;
  69.  
  70. : IFF.READ.CHKID  ( -- size chkid | 0 0 )
  71.     iff-pad 8 iff.read
  72.     8 -
  73.     IF
  74. \        ." Truncated chunk " r> .chkid cr  \ 00004 bogus r>
  75.         ." Truncated chunk " IFF-PAD @ .chkid cr
  76.         iff-stop on
  77.         iff-error on
  78.         0 0
  79.     ELSE
  80.         iff-pad cell+ @
  81.         iff-pad @
  82.     THEN
  83. ;
  84.  
  85. : IFF.READ.TYPE  ( -- typeid | 0 )
  86.     iff-pad 4 iff.read
  87.     4 -
  88.     IF ." Truncated type!" cr
  89.         iff-stop on iff-error on 0
  90.     ELSE
  91.         iff-pad @
  92.     THEN
  93. ;
  94.  
  95. : IFF.WRITE ( addr #bytes -- #bytes , write to open IFF file)
  96.     even-up
  97.     iff-fileid @ -rot    fwrite
  98. ;
  99.  
  100. : IFF.WRITE? ( addr #bytes -- error? , write to open IFF file or IFF.ERROR)
  101.     even-up dup>r iff.write r> -
  102.     IF
  103.         ." IFF.WRITE? failed!" cr
  104.         TRUE
  105.     ELSE
  106.         FALSE
  107.     THEN
  108. ;
  109.  
  110. : IFF.WRITE.CHKID?  ( size chkid -- error? , write chunk header )
  111.     iff-pad !
  112.     iff-pad cell+ !
  113.     iff-pad 8 iff.write?
  114. ;
  115.  
  116. : IFF.WRITE.CHUNK?  { addr size chid -- error? , write complete chunk }
  117.     size chid iff.write.chkid? 0=
  118.     IF
  119.         addr size iff.write?
  120.     ELSE
  121.         TRUE
  122.     THEN
  123. ;
  124.  
  125. : IFF.WHERE ( -- current_pos , in file )
  126.     iff-fileid @ 0 offset_current fseek
  127. ;
  128.  
  129. : IFF.SEEK ( position -- , in file )
  130.     iff-fileid @ swap offset_beginning fseek drop
  131. ;
  132.  
  133. : IFF.SCAN ( -- size , read chunk header and doit)
  134. \ This word leaves the file position just after the chunk data.
  135.     iff.read.chkid  ( -- size chkid)
  136.     dup
  137.     IF
  138.         iff.where >r
  139.         over >r
  140.         iff.process.chunk
  141.         r> even-up
  142.         dup r> + iff.seek ( move past chunk)
  143.     ELSE
  144.         drop
  145.     THEN
  146. ;
  147.  
  148. : IFF.HANDLE.FORM ( size -- , scan chunks in FORM )
  149.     1 iff-nested +!
  150.     iff.read.type drop \ .chkid cr
  151.     4 - ( subtract 4 for type )
  152.     BEGIN
  153.         dup 0>
  154.         iff-stop @ 0= AND  \ check for stop 00002
  155.     WHILE iff.scan 8 + ( account for header) -
  156.     REPEAT drop
  157.     -1 iff-nested +!
  158. ;
  159.  
  160. : IFF.HANDLE.CAT ( size -- )
  161.     ." CAT chunk found!" cr
  162.     iff.process.form  ( handle just like form )
  163. ;
  164.  
  165. : IFF.HANDLE.LIST ( size -- , report LIST found )
  166.     . ." LIST chunk found but not supported!" cr
  167. ;
  168.  
  169. ' iff.handle.form is iff.process.form
  170. ' iff.handle.cat  is iff.process.cat
  171. ' iff.handle.list is iff.process.list
  172.  
  173. : IFF.SPECIAL? ( size chkid -- done? )
  174.     true >r
  175.     CASE
  176.     'FORM' OF dup iff.process.form ENDOF
  177.     'LIST' OF dup iff.process.list ENDOF
  178.     'CAT'  OF dup iff.process.cat  ENDOF
  179.         ( size ckid -- )
  180.         rdrop false >r
  181.     ENDCASE drop r>
  182. ;
  183.  
  184. : IFF.VALIDATE ( -- ok? , make sure open file is IFF '85 )
  185.     iff.where
  186.     0 iff.seek
  187.     iff.read.type >r
  188.     r@ 'FORM' =
  189.     r@ 'CAT'  = OR
  190.     r> 'LIST' = OR
  191.     swap iff.seek
  192. ;
  193.  
  194. : $IFF.DOFILE? ( $filename -- error? , process file using deferred words)
  195.     0 iff-nested !
  196.     0 iff-stop ! \ 00002
  197.     0 iff-error ! \ 00003
  198.     $iff.open?
  199.     IF
  200.         iff.validate
  201.         IF  iff.scan drop
  202.             iff-error @
  203.         ELSE ."  Not an IFF'85 file!" cr
  204.             TRUE
  205.         THEN
  206.         iff.close
  207.     ELSE
  208.         TRUE
  209.     THEN
  210. ;
  211.  
  212. : $IFF.DOFILE ( $filename -- , process file using deferred words)
  213.     $iff.dofile? abort" Error in $IFF.DOFILE"
  214. ;
  215.  
  216. : IFF.DOFILE ( <filename> -- )
  217.     fileword $iff.dofile
  218. ;
  219.  
  220. : IFF.PRINT.CHUNK  ( size chkid -- )
  221.     >newline iff-nested @ 5 * spaces
  222.     2dup .chkid space .
  223.     iff.special? drop
  224. ;
  225.  
  226. : IFF.DUMP.CHUNK  ( size chkid -- )
  227.     >newline iff-nested @ 5 * spaces
  228.     2dup .chkid dup>r space .
  229.     iff.special? not
  230.     IF pad r@ 128 min iff.read pad swap dump
  231.     THEN
  232.     rdrop cr
  233. ;
  234.  
  235. : IFF.NOT.PROC ( size chkid -- , default for tell if chunk not used)
  236.     iff-warnings @
  237.     IF
  238.         >newline .chkid space . ." not used." cr
  239.     ELSE
  240.         2drop
  241.     THEN
  242. ;
  243.  
  244. ' iff.print.chunk is iff.process.chunk
  245.  
  246. : IFF.CHECK ( <filename> -- , print chunks )
  247.     what's iff.process.chunk
  248.     ' iff.print.chunk is iff.process.chunk
  249.     iff.dofile
  250.     is iff.process.chunk
  251. ;
  252.  
  253. : IFF.DUMP ( <filename> -- , print chunks )
  254.     what's iff.process.chunk
  255.     ' iff.dump.chunk is iff.process.chunk
  256.     iff.dofile
  257.     is iff.process.chunk
  258. ;
  259.  
  260. : IFF.READ.DATA { dsize | daddr -- addr | null , allocate space and read }
  261.     0 dsize even-up allocblock dup -> daddr
  262.     IF  daddr dsize iff.read
  263.         dsize -
  264.         IF ." IFF.READ.DATA - Truncated Data!" cr
  265.             daddr freeblock 0 -> daddr
  266.             goto.error
  267.         THEN
  268.     ELSE ." IFF.READ.DATA Could not allocate memory!" cr
  269.         goto.error
  270.     THEN
  271.     daddr
  272.     exit
  273. ERROR:
  274.     iff-stop on
  275.     iff-error on
  276.     0
  277. ;
  278.  
  279. \ Tools for writing an IFF file.
  280. : IFF.BEGIN.FORM?  ( type -- start-position error? )
  281.     iff.where
  282.     0 'FORM' iff.write.chkid? 
  283.     IF ( -- type sp )
  284.         nip TRUE
  285.     ELSE
  286.         swap iff-pad !
  287.         iff-pad 4 iff.write?
  288.     THEN
  289. ;
  290.  
  291. : IFF.END.FORM? ( start-position -- error? )
  292.     >r iff.where dup r@ - 8 -  ( size of 'FORM' chunk header )
  293.     iff-pad ! r> cell+ iff.seek
  294.     iff-pad 4 iff.write?  ( write size to FORM chuck header )
  295.     ( pos error? )
  296.     swap iff.seek  ( restore position )
  297. ;
  298.